home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / MACROS3.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  13KB  |  311 lines
  1. (in-package "LISP")
  2. (export '(ethe letf letf*))
  3. (in-package "SYSTEM")
  4. ;-------------------------------------------------------------------------------
  5. ; Wie THE, nur daß auch im compilierten Code der Typtest durchgeführt wird.
  6. (defmacro ethe (typespec form)
  7.   (let ((g (gensym)))
  8.     `(THE ,typespec
  9.        (LET ((,g (MULTIPLE-VALUE-LIST ,form)))
  10.          (IF (SYS::%THE ,g ',typespec)
  11.            (VALUES-LIST ,g)
  12.            (ERROR #+DEUTSCH "Die Form ~S lieferte ~:[keine Werte~;~:*~{~S~^ ; ~}~] ,~@
  13.                              das ist nicht vom Typ ~S."
  14.                   #+ENGLISH "The form ~S yielded ~:[no values~;~:*~{~S~^ ; ~}~] ,~@
  15.                              that's not of type ~S."
  16.                   #+FRANCAIS "La forme ~S a rendu ~:[aucune valeur~;~:*~{~S~^ ; ~}~] ,~@
  17.                               ceci n'est pas de type ~S."
  18.                   ',form ,g ',typespec
  19. ) )  ) ) ) )
  20. ;-------------------------------------------------------------------------------
  21. ; Macro LETF / LETF* wie LET, LET*, nur daß als "Variable" beliebige Places
  22. ; (wie bei SETF) zugelassen sind, inklusive VALUES, VALUES-LIST.
  23.  
  24. ; (LETF ((A form)) ...) --> (LET ((A form)) ...)
  25.  
  26. ; (LETF (((CAR A) form)) ...)
  27. ;   --> (LET* ((#:G1 A)
  28. ;              (#:G2 (CAR #:G1))
  29. ;              (#:G3 form))
  30. ;         (UNWIND-PROTECT
  31. ;           (PROGN (SYSTEM::%RPLACA #:G1 #:G3) ...)
  32. ;           (SYSTEM::%RPLACA #:G1 #:G2)
  33. ;       ) )
  34.  
  35. ; (LETF (((VALUES A B) form)) ...) --> (MULTIPLE-VALUE-BIND (A B) form ...)
  36.  
  37. ; (LETF (((VALUES (CAR A) (CDR B)) form)) ...)
  38. ;   --> (LET* ((#:G1 A)
  39. ;              (#:G2 (CAR #:G1))
  40. ;              (#:G3 B)
  41. ;              (#:G4 (CDR #:G3)))
  42. ;         (MULTIPLE-VALUE-BIND (#:G5 #:G6) form
  43. ;           (UNWIND-PROTECT
  44. ;             (PROGN (SYSTEM::%RPLACA #:G1 #:G5) (SYSTEM::%RPLACD #:G3 #:G6)
  45. ;                    ...
  46. ;             )
  47. ;             (SYSTEM::%RPLACA #:G1 #:G2) (SYSTEM::%RPLACA #:G3 #:G4)
  48. ;       ) ) )
  49.  
  50. ; (LETF (((VALUES-LIST A) form)) ...)
  51. ;   --> (LET ((A (MULTIPLE-VALUE-LIST form))) ...)
  52.  
  53. (defmacro LETF* (bindlist &body body &environment env)
  54.   (multiple-value-bind (body-rest declarations)
  55.       (SYSTEM::PARSE-BODY body nil env)
  56.     (let ((declare (if declarations `((DECLARE ,@declarations)) '())))
  57.       (values (expand-LETF* bindlist declare body-rest))
  58. ) ) )
  59.  
  60. ; expandiert ein LETF*, liefert die Expansion und
  61. ; T, falls diese Expansion mit einem LET* anfängt, dessen Bindungsliste
  62. ; erweitert werden darf.
  63. (defun expand-LETF* (bindlist declare body)
  64.   (if (atom bindlist)
  65.     (if bindlist
  66.       (error #+DEUTSCH "Dotted List im Code von LETF*, endet mit ~S"
  67.              #+ENGLISH "LETF* code contains a dotted list, ending with ~S"
  68.              #+FRANCAIS "Dans le code de LETF*, occurence d'une paire pointée terminée en ~S"
  69.              bindlist
  70.       )
  71.       (values `(LET* () ,@declare ,@body) t)
  72.     )
  73.     (let ((bind (car bindlist)) place form)
  74.       (if (atom bind) (setq place bind form nil)
  75.         (if (and (consp (cdr bind)) (null (cddr bind)))
  76.           (progn
  77.             (setq place (car bind) form (cadr bind))
  78.             (when (and (consp place) (eq (car place) 'VALUES-LIST) (eql (length place) 2))
  79.               (setq place (second place) form `(MULTIPLE-VALUE-LIST ,form))
  80.             )
  81.             (loop
  82.               (if (and (consp place) (eq (car place) 'THE) (eql (length place) 3))
  83.                 (setq place (third place) form `(THE ,(second place) ,form))
  84.                 (return)
  85.           ) ) )
  86.           (error #+DEUTSCH "Falsche Syntax in Bindung zu LETF* : ~S"
  87.                  #+ENGLISH "illegal syntax in LETF* binding: ~S"
  88.                  #+FRANCAIS "Syntaxe illégale dans une liaison pour LETF* : ~S"
  89.                  bind
  90.       ) ) )
  91.       (multiple-value-bind (rest-expanded flag)
  92.           (expand-LETF* (cdr bindlist) declare body)
  93.         (if (atom place)
  94.           (values
  95.             (if flag
  96.               `(LET* ,(cons (list place form) (cadr rest-expanded))
  97.                  ,@(cddr rest-expanded)
  98.                )
  99.               `(LET* ((,place ,form)) ,@declare ,rest-expanded)
  100.             )
  101.             t
  102.           )
  103.           (if (eq (car place) 'VALUES)
  104.             (if (every #'symbolp place)
  105.               (values
  106.                 `(MULTIPLE-VALUE-BIND ,(cdr place) ,form ,@declare ,rest-expanded)
  107.                 nil
  108.               )
  109.               (values
  110.                 (do ((bindlist nil)
  111.                      (storetemps nil)
  112.                      (stores1 nil)
  113.                      (stores2 nil)
  114.                      (subplacesr (cdr place)))
  115.                     ((atom subplacesr)
  116.                      `(LET* ,(nreverse bindlist)
  117.                         ,@declare
  118.                         (MULTIPLE-VALUE-BIND ,(nreverse storetemps) ,form
  119.                           ,@declare
  120.                           (UNWIND-PROTECT
  121.                             (PROGN ,@(nreverse stores1) ,rest-expanded)
  122.                             ,@(nreverse stores2)
  123.                     ) ) ) )
  124.                   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  125.                       (get-setf-method (pop subplacesr))
  126.                     (setq bindlist
  127.                       (cons (list (first SM3) SM5)
  128.                             (nreconc (mapcar #'list SM1 SM2) bindlist)
  129.                     ) )
  130.                     (let ((storetemp (gensym)))
  131.                       (setq storetemps (cons storetemp storetemps))
  132.                       (setq stores1 (cons (subst storetemp (first SM3) SM4) stores1))
  133.                     )
  134.                     (setq stores2 (cons SM4 stores2))
  135.                 ) )
  136.                 t
  137.             ) )
  138.             (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place)
  139.               (let ((formvar (gensym)))
  140.                 (values
  141.                   `(LET* (,.(mapcar #'list SM1 SM2)
  142.                           (,(first SM3) ,SM5)
  143.                           (,formvar ,form))
  144.                      ,@declare
  145.                      (UNWIND-PROTECT
  146.                        (PROGN ,(subst formvar (first SM3) SM4) ,rest-expanded)
  147.                        ,SM4
  148.                    ) )
  149.                   t
  150.             ) ) )
  151. ) ) ) ) ) )
  152.  
  153. (defmacro LETF (bindlist &body body &environment env)
  154.   (multiple-value-bind (body-rest declarations)
  155.       (SYSTEM::PARSE-BODY body nil env)
  156.     (let ((declare (if declarations `((DECLARE ,@declarations)) '()))
  157.           (let-list nil))
  158.       (multiple-value-bind (let*-list let/let*-list uwp-store1 uwp-store2)
  159.           (expand-LETF bindlist)
  160.         ; mehrfach folgendes anwenden:
  161.         ; endet let*-list mit (#:G form) und kommt in let/let*-list (var #:G)
  162.         ; vor, so dürfen beide gestrichen werden, und dafür kommt (var form)
  163.         ; an den Anfang von let-list.
  164.         (setq let*-list (nreverse let*-list))
  165.         (loop
  166.           (unless (and (consp let*-list)
  167.                        (let ((last (caar let*-list)))
  168.                          (and (symbolp last) (null (symbol-package last))
  169.                               (dolist (bind let/let*-list nil)
  170.                                 (when (eq (second bind) last)
  171.                                   (push (list (first bind) (second (car let*-list)))
  172.                                         let-list
  173.                                   )
  174.                                   (setq let/let*-list
  175.                                     (delete last let/let*-list :key #'second
  176.                                             :test #'eq :count 1
  177.                                   ) )
  178.                                   (setq let*-list (cdr let*-list))
  179.                                   (return t)
  180.                   )    ) )    ) )
  181.             (return)
  182.         ) )
  183.         (setq let*-list (nreverse let*-list))
  184.         ; Nun muß folgendes gemacht werden:
  185.         ; 1. Die Bindungen von let*-list mit LETF* aktivieren,
  186.         ; 2. die Bindungen von let-list mit LET aktivieren,
  187.         ; 3. in beliebiger Reihenfolge:
  188.         ;    a. die Bindungen von let/let*-list mit LET oder LET* aktivieren,
  189.         ;    b. die Bindungen von uwp-store1 mit UNWIND-PROTECT aktivieren
  190.         ;       und danach mit uwp-store2 deaktivieren.
  191.         ; Beispielsweise:
  192. #|      `(LETF* ,let*-list
  193.            ,@declare
  194.            (LET ,let-list
  195.              ,@declare
  196.              (LET* ,let/let*-list
  197.                ,@declare
  198.                `(UNWIND-PROTECT (PROGN ,@uwp-store1 ,@body-rest) ,@uwp-store2)
  199.          ) ) )
  200. |#
  201.         (let ((body body-rest) ; eine Formenliste ohne Deklarationen
  202.               (1form nil)) ; zeigt an, ob body aus einer einzigen Form besteht
  203.           (when uwp-store1
  204.             (setq body `((UNWIND-PROTECT (PROGN ,@uwp-store1 ,@body) ,@uwp-store2))
  205.                   1form t
  206.           ) )
  207.           (when let/let*-list
  208.             (setq body `((LET* ,let/let*-list ,@declare ,@body)) 1form t)
  209.           )
  210.           (when let-list
  211.             (setq body `((LET ,let-list ,@declare ,@body)) 1form t)
  212.           )
  213.           (when let*-list
  214.             (setq body `((LETF* ,let*-list ,@declare ,@body)) 1form t)
  215.           )
  216.           (if (and 1form (or (null declare) (not (eq (caar body) 'unwind-protect))))
  217.             ; eine Form, keine Deklarationen oder fängt mit letf*/let/let* an
  218.             (car body)
  219.             ; allgemein
  220.             `(LET () ,@declare (PROGN ,@body))
  221. ) ) ) ) ) )
  222.  
  223. ; expandiert ein LETF, liefert:
  224. ; eine Bindungsliste für LETF*,
  225. ; eine Bindungsliste für LET/LET* (Reihenfolge der Bindung darin beliebig),
  226. ; eine Liste von Bindungsanweisungen, eine Liste von Entbindungsanweisungen
  227. ; (beide gleich lang).
  228. (defun expand-LETF (bindlist)
  229.   (if (atom bindlist)
  230.     (if bindlist
  231.       (error #+DEUTSCH "Dotted List im Code von LETF, endet mit ~S"
  232.              #+ENGLISH "LETF code contains a dotted list, ending with ~S"
  233.              #+FRANCAIS "Dans le code de LETF, occurence d'une paire pointée terminée en ~S"
  234.              bindlist
  235.       )
  236.       (values '() '() '() '())
  237.     )
  238.     (let ((bind (car bindlist)) place form)
  239.       (if (atom bind) (setq place bind form nil)
  240.         (if (and (consp (cdr bind)) (null (cddr bind)))
  241.           (progn
  242.             (setq place (car bind) form (cadr bind))
  243.             (when (and (consp place) (eq (car place) 'VALUES-LIST) (eql (length place) 2))
  244.               (setq place (second place) form `(MULTIPLE-VALUE-LIST ,form))
  245.             )
  246.             (loop
  247.               (if (and (consp place) (eq (car place) 'THE) (eql (length place) 3))
  248.                 (setq place (third place) form `(THE ,(second place) ,form))
  249.                 (return)
  250.           ) ) )
  251.           (error #+DEUTSCH "Falsche Syntax in Bindung zu LETF : ~S"
  252.                  #+ENGLISH "illegal syntax in LETF binding: ~S"
  253.                  #+FRANCAIS "Syntaxe illégale dans une liaison pour LETF : ~S"
  254.                  bind
  255.       ) ) )
  256.       (multiple-value-bind (L1 L2 L3 L4) (expand-LETF (cdr bindlist))
  257.         (if (atom place)
  258.           (let ((g (gensym)))
  259.             (values (cons (list g form) L1) (cons (list place g) L2) L3 L4)
  260.           )
  261.           (if (eq (car place) 'VALUES)
  262.             (if (every #'symbolp place)
  263.               (let ((gs (mapcar #'(lambda (subplace)
  264.                                     (declare (ignore subplace))
  265.                                     (gensym)
  266.                                   )
  267.                                 (cdr place)
  268.                    ))   )
  269.                 (values
  270.                   (cons (list (cons 'VALUES gs) form) L1)
  271.                   (nconc (mapcar #'list (cdr place) gs) L2)
  272.                   L3
  273.                   L4
  274.               ) )
  275.               (do ((bindlist nil)
  276.                    (storetemps nil)
  277.                    (stores1 nil)
  278.                    (stores2 nil)
  279.                    (subplacesr (cdr place)))
  280.                   ((atom subplacesr)
  281.                    (values
  282.                      (nreconc bindlist
  283.                               (cons (list (cons 'VALUES storetemps) form) L1)
  284.                      )
  285.                      L2
  286.                      (nreconc stores1 L3)
  287.                      (nreconc stores2 L4)
  288.                   ))
  289.                 (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  290.                     (get-setf-method (pop subplacesr))
  291.                   (setq bindlist
  292.                     (cons (list (first SM3) SM5)
  293.                           (nreconc (mapcar #'list SM1 SM2) bindlist)
  294.                   ) )
  295.                   (let ((storetemp (gensym)))
  296.                     (setq storetemps (cons storetemp storetemps))
  297.                     (setq stores1 (cons (subst storetemp (first SM3) SM4) stores1))
  298.                   )
  299.                   (setq stores2 (cons SM4 stores2))
  300.             ) ) )
  301.             (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place)
  302.               (let ((g (gensym)))
  303.                 (values
  304.                   `(,.(mapcar #'list SM1 SM2) (,(first SM3) ,SM5) (,g ,form))
  305.                   L2
  306.                   (cons (subst g (first SM3) SM4) L3)
  307.                   (cons SM4 L4)
  308.             ) ) )
  309. ) ) ) ) ) )
  310.  
  311.